home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / vcsCore.tcl < prev    next >
Encoding:
Text File  |  2001-01-08  |  10.2 KB  |  351 lines
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Part of AlphaTcl - core Tcl engine
  4.  # 
  5.  #  FILE: "vcsCore.tcl"
  6.  #                                    created: 03/23/2000 {10:59:22 AM} 
  7.  #                                last update: 1/8/2001 {10:36:27 AM} 
  8.  #                                
  9.  # ========================================================================
  10.  #           Copyright (c) 1998-2001 Jon Guyer, Vince Darley
  11.  #                         All rights reserved
  12.  # ========================================================================
  13.  # Permission to use, copy, modify, and distribute this software and its
  14.  # documentation for any purpose and without fee is hereby granted,
  15.  # provided that the above copyright notice appear in all copies and that
  16.  # both that the copyright notice and warranty disclaimer appear in
  17.  # supporting documentation.
  18.  # 
  19.  # The authors disclaim all warranties with regard to this software,
  20.  # including all implied warranties of merchantability and fitness.  In
  21.  # no event shall the authors be liable for any special, indirect or
  22.  # consequential damages or any damages whatsoever resulting from loss of
  23.  # use, data or profits, whether in an action of contract, negligence or
  24.  # other tortuous action, arising out of or in connection with the use or
  25.  # performance of this software.
  26.  # ========================================================================
  27.  #  
  28.  #  For the moment this code is designed to work with Tcl 7.x as
  29.  #  well as 8.x, which is why namespaces aren't handled in the most
  30.  #  elegant way: we may not have them!
  31.  # ###################################################################
  32.  ##
  33.  
  34. alpha::extension vcs 0.1a8 {
  35.     namespace eval vcs {}
  36.     # This allows us to attach version control information to any fileset
  37.     fileset::attachNewInformation * [list global versionControlSystem] "Version Control System" No \
  38.       "The version control system under which these files are placed" vcs::vcsSystemModified
  39.     # The current version control system.
  40.     newPref var versionControlSystem "No" vcs "" vcs::system "array"
  41.     # Called when the user ctrl/cmd-clicks on the lock icon
  42.     hook::register unlockHook vcs::manualUnlock *
  43.     hook::register lockHook vcs::manualLock *
  44.     # Add a version control prefs page, mapped to the 'vcs' storage
  45.     package::addPrefsDialog versionControl vcs
  46.     newPref flag addNameOfSystemToPopup 1 vcs 
  47. } help {
  48.     AlphaTcl's core version control functionality is provided by this
  49.     package.
  50. }
  51.  
  52. namespace eval vcs {}
  53.  
  54. set vcs::system(No) vcs
  55.  
  56. proc vcs::menuProc {item} {
  57.     switch -- $item {
  58.     lock {
  59.         # Right now this just implements non-vcs connected
  60.         # lock/unlock actions
  61.         setWinInfo read-only 1
  62.     }
  63.     unlock {
  64.         # Right now this just implements non-vcs connected
  65.         # lock/unlock actions
  66.         setWinInfo read-only 0
  67.     }
  68.     default {
  69.         # add checkIn undoCheckout makeWritable checkOut
  70.         # refetchReadOnly fetchReadOnly
  71.         set name [win::Current]
  72.         vcs::call $item $name
  73.         vcs::syncLockStatus $name
  74.     }
  75.     }
  76. }
  77.  
  78. proc vcs::vcsSystemModified {fset value} {
  79.     hook::callAll vcsSystemModified $value $fset
  80. }
  81.  
  82. proc vcs::register {type {ns ""}} {
  83.     global vcs::system
  84.     if {![string length $ns]} { set ns $type }
  85.     set vcs::system($type) $ns
  86. }
  87.  
  88. proc vcs::getNamespace {} {
  89.     global vcs::system
  90.     set vcs::system([vcs::getSystem])
  91. }
  92.  
  93. proc vcs::getState {name} {
  94.     return ""
  95. }
  96.  
  97. proc vcs::getInfo {infoName} {
  98.     return [fileset::getInformation [fileset::checkCurrent] $infoName]
  99. }
  100.  
  101. proc vcs::getSystem {} {
  102.     global vcsmodeVars
  103.     set fset [fileset::checkCurrent]
  104.     if {![string length $fset]} {
  105.     if {[info exists vcsmodeVars(versionControlSystem)]} {
  106.         return $vcsmodeVars(versionControlSystem)
  107.     } else {
  108.         return "No"
  109.     }
  110.     } else {
  111.     return [fileset::getInformation $fset "Version Control System"]
  112.     }
  113. }
  114.  
  115. proc vcs::call {what args} {
  116.     set ns [vcs::getNamespace]
  117.     if {[catch {eval ${ns}::${what} $args} err]} {
  118.     message $err
  119.     }
  120.     return $err
  121. }
  122.  
  123. proc vcs::syncLockStatus {name} {
  124.     getFileInfo [win::StripCount $name] fileState
  125.     getWinInfo winState
  126.     if {$winState(read-only) != $fileState(readonly)} {
  127.     setWinInfo read-only $fileState(readonly)
  128.     }
  129. }
  130.  
  131. proc vcs::manualUnlock {name} {
  132.     vcs::call unlock $name
  133. }
  134.  
  135. proc vcs::manualLock {name} {
  136.     vcs::call lock $name
  137. }
  138.  
  139. proc vcs::showDifferences {name} {
  140. }
  141.  
  142. proc vcs::lock {name} {
  143.     setWinInfo read-only 1
  144. }
  145.  
  146. proc vcs::unlock {name} {
  147.     setWinInfo read-only 0
  148. }
  149.  
  150. proc vcs::checkIn {name} {
  151. }
  152.  
  153. proc vcs::checkOut {name} {
  154. }
  155.  
  156. proc vcs::undoCheckout {name} {
  157. }
  158.  
  159. proc vcs::refetchReadOnly {name} {
  160. }
  161.  
  162. proc vcs::otherCommands {state} {
  163.     # nothing by default
  164. }
  165.  
  166. # This is a callback routine for Alpha 8's VCS popup menu
  167. proc ckidMenu {ckid locked} {
  168.     global menu::items
  169.     set state [lindex [list "no-vcs" "checked-out" "read-only" "mro"] $ckid]
  170.     set menu::items(ckid) [vcs::menuItems $state $locked]
  171.     menu::buildOne ckid
  172.     return "ckid"
  173. }
  174.  
  175. # Used in a callback from Alpha 8 via the above proc, or directly
  176. # in Alphatk.  An empty state means AlphaTcl has no idea how to
  177. # get any vcs information for this file (e.g. we're running
  178. # Alphatk), a state of 'no-cvs' means this file doesn't appear
  179. # to be under version control, but we should really double-check.
  180. proc vcs::menuItems {state locked} {
  181.     global vcsmodeVars
  182.     # ckid icon suite runs from 490 to 494
  183.     # subtract 208 (why?!?) + 256
  184.  
  185.     if {$state == "" || $state == "no-cvs"} {
  186.     # Unknown state
  187.     set state [vcs::call getState [win::Current]]
  188.     }
  189.     
  190.     if {[info exists vcsmodeVars(addNameOfSystemToPopup)]
  191.     &&    $vcsmodeVars(addNameOfSystemToPopup)} {
  192.     lappend res "\(using[vcs::getSystem]VCSystem"
  193.     } else {
  194.     set res [list]
  195.     }
  196.     
  197.     # Active items should depend on whether we have a VCS system 
  198.     # active and on the state of the file.
  199.     # 
  200.     # Currently 'read-only' means the file is either 'up-to-date'
  201.     # or 'needs-patch', but we don't know which (it appears as if
  202.     # the ckid resource doesn't give us enough information?).
  203.     
  204.     eval lappend res [vcs::call getMenuItems $state]
  205.     
  206.     if {[llength $res]} {
  207.     lappend res "(-)"
  208.     }
  209.     
  210.     if {$locked} {
  211.     lappend res "unlock[icon::FromID 494]"
  212.     } else {
  213.     lappend res "lock[icon::FromID 493]"
  214.     }
  215.     
  216. #     # Add any other items the vcs system wants to use
  217. #     set extras [vcs::call otherCommands $state]
  218. #     if {[llength $extras]} {
  219. #     lappend res "(-)"
  220. #     eval lappend res $extras
  221. #     }
  222.     
  223.     set res
  224. }
  225.  
  226. ## 
  227.  # -------------------------------------------------------------------------
  228.  # 
  229.  # "vcs::getMenuItems" --
  230.  # 
  231.  #  Called when there is no active VC System
  232.  #  All items disabled.
  233.  # -------------------------------------------------------------------------
  234.  ##
  235. proc vcs::getMenuItems {state} {
  236.     switch -- $state {
  237.       "no-vcs" { 
  238.       lappend res "\(add…[icon::FromID 491]"    
  239.       }
  240.       "checked-out" { 
  241.       lappend res                                   \
  242.         "\(checkIn…[icon::FromID 490]"              \
  243.         "\(undoCheckout[icon::FromID 491]"          \
  244.         "\(makeWritable[icon::FromID 492]"          \
  245.         "(-)"                                       \
  246.         "\(showDifferences" 
  247.       }
  248.       "read-only" { 
  249.       lappend res                                   \
  250.         "\(checkOut…[icon::FromID 490]"             \
  251.         "\(refetchReadOnly[icon::FromID 491]"       \
  252.         "\(makeWritable[icon::FromID 492]"        \
  253.         "(-)"                                       \
  254.         "\(showDifferences"
  255.       }
  256.       "mro" { 
  257.       lappend res                                   \
  258.         "\(checkOut…[icon::FromID 490]"        \
  259.         "\(fetchReadOnly[icon::FromID 491]"        \
  260.         "\(makeWritable[icon::FromID 492]"        \
  261.         "(-)"                                       \
  262.         "\(showDifferences"
  263.       }
  264.       "up-to-date" {
  265.       lappend res                                   \
  266.         "\(checkOut…[icon::FromID 490]"        \
  267.         "\(makeWritable[icon::FromID 492]"        \
  268.       }
  269.       "needs-patch" { 
  270.       lappend res                                   \
  271.         "\(refetchReadOnly[icon::FromID 491]"       \
  272.         "(-)"                                       \
  273.         "\(showDifferences" 
  274.       }
  275.       "" {
  276.       # no version control registered, or not possible 
  277.       # to place under version control with current
  278.       # system
  279.       set res {}
  280.       }
  281.       default {
  282.       error "Bad response '$state' received from vcs system"
  283.       }
  284.     }
  285.     
  286.     return $res
  287. }
  288.  
  289. ## 
  290.  # -------------------------------------------------------------------------
  291.  # 
  292.  # "vcs::generalMenuItems" --
  293.  # 
  294.  #  General utility function.
  295.  #  Most VC Systems will use this to build the bulk of their items
  296.  # -------------------------------------------------------------------------
  297.  ##
  298. proc vcs::generalMenuItems {state} {
  299.     switch -- $state {
  300.       "no-vcs" { 
  301.       lappend res "add…[icon::FromID 491]"    
  302.       }
  303.       "checked-out" { 
  304.       lappend res                                   \
  305.         "checkIn…[icon::FromID 490]"                \
  306.         "undoCheckout[icon::FromID 491]"            \
  307.         "\(makeWritable[icon::FromID 492]"          \
  308.         "(-)"                                       \
  309.         "showDifferences" 
  310.       }
  311.       "read-only" { 
  312.       lappend res                                   \
  313.         "checkOut…[icon::FromID 490]"               \
  314.         "refetchReadOnly[icon::FromID 491]"            \
  315.         "makeWritable[icon::FromID 492]"        \
  316.         "(-)"                                       \
  317.         "showDifferences"
  318.       }
  319.       "mro" { 
  320.       lappend res                                   \
  321.         "checkOut…[icon::FromID 490]"        \
  322.         "fetchReadOnly[icon::FromID 491]"        \
  323.         "\(makeWritable[icon::FromID 492]"        \
  324.         "(-)"                                       \
  325.         "showDifferences"
  326.       }
  327.       "up-to-date" {
  328.       lappend res                                   \
  329.         "checkOut…[icon::FromID 490]"        \
  330.         "makeWritable[icon::FromID 492]"        \
  331.       }
  332.       "needs-patch" { 
  333.       lappend res                                   \
  334.         "refetchReadOnly[icon::FromID 491]"            \
  335.         "(-)"                                       \
  336.         "showDifferences" 
  337.       }
  338.       "" {
  339.       # no version control registered, or not possible 
  340.       # to place under version control with current
  341.       # system
  342.       set res {}
  343.       }
  344.       default {
  345.       error "Bad response '$state' received from vcs system"
  346.       }
  347.     }
  348.     
  349.     return $res
  350. }
  351.